home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
001
/
wwiv.arc
/
COMMON.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1986-04-07
|
31KB
|
1,198 lines
CONST strlen=160;
comnum=1;
maxbaud=1200;
maxusers=500;
dsaves : Integer = 0;
buffer_Max = 5120;
comptyp:array[1..8] of string[14]=('IBM','APPLE','TRS-80','Z-80 CP/M',
'COMMODORE','ATARI','DUMB TERMINAL','OTHER');
TYPE str=string[strlen];
restrictions=(rlogon,rchat,rvalidate,rbackspace,ramsg,rpostan,
rpost,remail,rvoting,rmsg);
acrq='@'..'G';
newtyp=(rp,lt,rm);
deflts=(spcsr,onekey,wordwrap,pause);
anontyp=(no,yes,forced,dearabby);
ansttype=(postn,emailn,pana,sanm,cosysop,lcosysop);
opts=(alert,smw,nomail);
pnr=record name:string[40]; number:string[14]; hs:byte; end;
slr=record
ttime:byte;
mallowed:integer;
emails,posts:byte;
anst:set of ansttype;
end;
messages=record
ltr:char;
number:integer;
ext:byte;
end;
smalrec=record
name:string[25];
number:integer;
end;
userrec=record
name:string[25];
realname:string[14];
deleted:boolean;
pw:string[8];
ph:string[12];
waiting:byte;
laston:string[10];
loggedon:integer;
msgpost:integer;
emailsent:integer;
feedback:integer;
linelen:byte;
pagelen:byte;
defaults:set of deflts;
ontoday:byte;
illegal:byte;
cursor:string[10];
sl:byte;
ac:set of restrictions;
ar:set of acrq;
qscan:array[1..19] of messages;
qscn:array[1..19] of boolean;
macro:array[1..2] of string[79];
comptype:byte;
option:set of opts;
vote:array[1..9] of byte;
sbn:byte;
dsl:byte;
uploads,downloads:integer;
uk,dk:integer;
end;
boardrec=record
name:string[25];
filename:string[12];
sl:byte;
maxmsgs:byte;
pw:string[10];
anonymous:anontyp;
ar:acrq;
key:char;
end;
msgstat=(validated,unvalidated,deleted);
messagerec=record
title:string[30];
messagestat:msgstat;
message:messages;
owner:integer;
date:integer;
mage:byte;
end;
systatrec=record
boardpw:string[8];
sysoppw:string[8];
hmsg:messages;
users:integer;
lastdate:string[8];
callernum:integer;
activetoday:integer;
callstoday:integer;
msgposttoday:integer;
emailtoday:integer;
fbacktoday:integer;
uptoday:integer;
closedsystem:boolean;
end;
blk=array[1..255] of byte;
mailrec=record
title:string[30];
from,destin:integer;
msg:messages;
date:integer;
mage:byte;
end;
gft=record
num:integer;
title:string[40];
filen:string[12];
end;
charfil=text;
smr=record
msg:str;
destin:integer;
end;
vdatar=record
question:string[79];
numa:integer;
answ:array[0..9] of record
ans:string[25];
numres:integer;
end;
end;
regs=record ax,bx,cx,dx,bp,si,di,ds,es,flags:integer; end;
ulrec=record
name:string[25];
filename:string[12];
password:string[10];
dsl:byte;
maxfiles:integer;
end;
ulfrec=record
filename:string[12];
description:string[60];
res:array[1..17] of byte;
ft:array[1..3] of byte;
blocks:integer;
owner:integer;
date:string[8];
daten:integer;
end;
strptr=^strrec;
strrec=record
i:str;
next,last:strptr;
end;
var sf:file of smalrec;
uf:file of userrec;
bf:file of boardrec;
mf:file of messagerec;
mailfile:file of mailrec;
sysopf:charfil;
slf:file of slr;
seclev:array[0..255] of slr;
systatf:file of systatrec;
systat:systatrec;
sr:smalrec;
thisline,chatr,buf,spd,irt,lastname,ll,cursor,i:str;
thisuser,user:userrec;
boards:array[1..19] of boardrec;
fw,extramsgs,mread,board,numboards,t,usernum:integer;
pap,lil,realsl,ftoday,ptoday,etoday:integer;
c,ID:char;
hungup,useron,next,chatcall,expert,doneday,echo,hangup,incom,outcom:boolean;
extratime,timeon:real;
macok,lan,enddayf,ch,quit:boolean;
buffer:Array[0..buffer_Max] of Char;
comport,base:Integer;
Async_Irq:Integer;
buffer_Head,buffer_tail,buffer_newtail:Integer;
smf:file of smr;
srl:array[0..maxusers] of smalrec;
vqu:array[1..9] of boolean;
ret:byte absolute cseg:$0080;
ldate:integer;
maxspd:integer;
cmd:char;
help:array[1..25000] of char;
helpi:array['0'..'^'] of integer;
helpl:char;
ihelp:boolean;
cf:text; cfo,okt:boolean;
elevel:byte;
function freek:integer;
var r:regs;
begin
r.ax:=$3600;
r.dx:=0;
msdos(r);
freek:=trunc(1.0*r.bx*r.ax*r.cx/1024.0);
end;
function cs:boolean;
begin
cs:=cosysop in seclev[thisuser.sl].anst;
end;
function so:boolean;
begin
so:=thisuser.sl=255;
end;
function lcs:boolean;
begin
lcs:=cs or ((lcosysop in seclev[thisuser.sl].anst) and ((board=thisuser.sbn) or (thisuser.sbn=0)));
end;
function commpressed : boolean;
begin
commpressed := (buffer_tail<>buffer_head);
end;
procedure dump;
begin
inline($FA);
buffer_head:=0;
buffer_tail:=buffer_head;
inline($FB);
end;
procedure async_isr;
begin
inline($50/$53/$52/$1E/$FB/$2E/$FF/$36/dsaves/$1F/$8B/$16/base/
$EC/$8B/$1E/buffer_Head/$88/$87/buffer/$43/$81/$FB/buffer_Max/$7E/
$02/$33/$DB/$3B/$1E/buffer_Tail/$74/$04/$89/$1E/buffer_Head/$FA/
$B0/$20/$E6/$20/$1F/$5A/$5B/$58/$5C/$5D/$CF);
end;
procedure remove_port;
var
i,m:integer;
begin
inline($FA);
i := port[$21];
m := 1 shl Async_Irq;
port[$21] := i or m;
port[2+base] := 0;
port[4+base] := 1;
inline($FB);
end;
procedure term_ready(s:Boolean);
var x:byte;
begin
x := port[4+base] and $FE;
if s then x:=x+1;
port[4+base] := x;
end;
procedure set_baud(r:integer);
var rl:real; a:byte;
begin
if (r>=300) and (r<=9600) then begin
rl:=115200.0/r;
r:=trunc(rl);
a:=port[3+base] or 128;
port[base+3]:=a;
port[base]:=lo(r);
port[1+base]:=hi(r);
port[3+base]:=a and 127;
end;
end;
procedure iport;
var
i,m:Integer;
regs:record ax,bx,cx,dx,bp,si,di,ds,es,flags:integer; end;
begin
dsaves:= DSeg;
If ComPort = 2 Then begin
base := $2f8;
Async_Irq := 3;
end else begin
base := $3f8;
Async_Irq := 4;
end;
If (Port[2+base] and $00F8) <> 0 Then
begin writeln('Illegal com port number'); halt; end
else begin
buffer_Head:=0; buffer_Tail:=0; port[base+3]:=$03;
with regs do begin
ax:=$2500+((async_irq+8) and $00ff); ds:=cseg;
dx:=ofs(async_isr); msdos(regs);
end;
inline($FA);
i:=port[5+base];
i:=port[base];
i:=port[$21];
m:=(1 shl Async_Irq) xor $00FF;
port[$21] := i and m;
port[1+base] := $01;
i := port[4+base];
port[4+base] := i or $08;
term_ready(true);
inline($FB);
end;
end;
function cinkey:char;
var t:char;
begin
if buffer_Head = buffer_Tail Then
t:=#0
else begin
inline($FA);
t:=buffer[buffer_Tail];
buffer_Tail:=(buffer_Tail+1) mod (buffer_max+1);
inline($FB);
end;
cinkey:=chr(ord(t) and 127);
end;
function cinkey1:char;
var t:char;
begin
if buffer_Head = buffer_Tail Then
t:=#0
else begin
inline($FA);
t:=buffer[buffer_Tail];
buffer_Tail:=(buffer_Tail+1) mod (buffer_max+1);
inline($FB);
end;
cinkey1:=t;
end;
procedure o1(c:char);
begin
while (port[base+5] and 32)=0 do;
port[base]:=ord(c);
end;
procedure o(c:char);
begin
if outcom and (c<>#1) then o1(c);
end;
FUNCTION TIMER: REAL;
VAR REG: RECORD
AX,BX,CX,DX,BP,SI,DI,DS,ES,FLAGS: INTEGER;
END;
H,M,S,T: REAL;
BEGIN
REG.AX := 44 * 256;
MsDos(REG);
H := (REG.CX DIV 256);
M := (REG.CX MOD 256);
S := (REG.DX DIV 256);
T := (REG.DX MOD 256);
TIMER := H*3600 + M*60 + S + T/100;
END;
function sysop1:boolean;
begin
if (mem[0:1047] and 16)=0 then sysop1:=false else sysop1:=true;
end;
function sysop:boolean;
begin
sysop:=sysop1;
if rchat in thisuser.ac then sysop:=false;
end;
procedure bs;
var x,y:integer;
begin
x:=wherex; y:=wherey; if x>1 then x:=x-1 else
if y>1 then begin x:=80; y:=y-1; end;
gotoxy(x,y);
end;
procedure backs;
begin
o(chr(8)); bs; write(' '); o(' '); o(chr(8)); bs;
end;
procedure sl1(i:str);
begin
if (realsl<>255) or incom then begin
assign(sysopf,'gfiles\sysop.log'); {$I-} append(sysopf);{$I+}
if ioresult<>0 then
rewrite(sysopf);
writeln(sysopf,i);
close(sysopf);
end;
end;
procedure sysoplog(i:str);
begin
sl1(' '+i);
end;
function tch(i:str):str;
begin
if length(i)>2 then i:=copy(i,length(i)-1,2) else
if length(i)=1 then i:='0'+i;
tch:=i;
end;
FUNCTION TIME:STR;
VAR REG: RECORD
AX,BX,CX,DX,BP,SI,DI,DS,ES,FLAGS: INTEGER;
END;
H,M,S:string[4];
BEGIN
reg.ax:=$2c00; intr($21,reg);
str(reg.cx shr 8,h); str(reg.cx mod 256,m); str(reg.dx shr 8,s);
time:=tch(h)+':'+tch(m)+':'+tch(s);
END;
FUNCTION DATE:STR;
VAR REG: RECORD
AX,BX,CX,DX,BP,SI,DI,DS,ES,FLAGS: INTEGER;
END;
M,D,Y:STRing[4];
BEGIN
reg.ax:=$2a00; msdos(reg); str(reg.cx,y); str(reg.dx mod 256,d);
str(reg.dx shr 8,m);
date:=tch(m)+'/'+tch(d)+'/'+tch(y);
END;
FUNCTION value(I:str):INTEGER;
VAR N,N1:INTEGER;
BEGIN
VAL(I,N,N1);
IF N1<>0 THEN BEGIN
I:=COPY(I,1,N1-1);
VAL(I,N,N1)
END;
VaLue:=N;
if i='' then value:=0;
END;
function cstr(i:integer):str;
var c:str;
begin
str(i,c); cstr:=c;
end;
function nam:str;
var s:str; i:integer; tf:boolean;
begin
s:=thisuser.name;
tf:=true;
for i:=1 to length(s) do
if s[i]<'A' then
tf:=true
else begin
if (s[i]<='Z') and not tf then
s[i]:=chr(ord(s[i])+32);
tf:=false;
end;
nam:=s+' #'+cstr(usernum);
end;
function leapyear(yr:integer):boolean;
begin
leapyear:=(yr mod 4=0) and ((yr mod 100<>0) or (yr mod 400=0));
end;
function days(mo,yr:integer):integer;
var d:integer;
begin
d:=value(copy('312831303130313130313031',1+(mo-1)*2,2));
if (mo=2) and leapyear(yr) then d:=d+1;
days:=d;
end;
function daycount(mo,yr:integer):integer;
var m,t:integer;
begin
t:=0;
for m:=1 to (mo-1) do t:=t+days(m,yr);
daycount:=t;
end;
function daynum(dt:str):integer;
var d,m,y,t,c:integer;
begin
t:=0;
m:=value(copy(dt,1,2));
d:=value(copy(dt,4,2));
y:=value(copy(dt,7,2))+1900;
for c:=1985 to y-1 do
if leapyear(c) then t:=t+366 else t:=t+365;
t:=t+daycount(m,y)+(d-1);
daynum:=t;
if y<1985 then daynum:=0;
end;
function dat:str;
var ap,x,y:str; i:integer;
begin
case daynum(date) mod 7 of
0:x:='Tue';
1:x:='Wed';
2:x:='Thu';
3:x:='Fri';
4:x:='Sat';
5:x:='Sun';
6:x:='Mon';
end;
case value(copy(date,1,2)) of
1:y:='Jan';
2:y:='Feb';
3:y:='Mar';
4:y:='Apr';
5:y:='May';
6:y:='Jun';
7:y:='Jul';
8:y:='Aug';
9:y:='Sep';
10:y:='Oct';
11:y:='Nov';
12:y:='Dec';
end;
x:=x+' '+y+' '+copy(date,4,2)+', '+cstr(1900+value(copy(date,7,2)));
y:=time; i:=value(copy(y,1,2));
if i>11 then ap:='pm' else ap:='am';
if i>12 then i:=i-12;
if i=0 then i:=12;
dat:=cstr(i)+copy(y,3,3)+' '+ap+' '+x;
end;
function cdet:boolean;
begin
cdet:=(port[base+6] and 128)<>0;
end;
procedure checkhangup;
begin
if incom and not cdet and (not hangup) then begin
hangup:=true; hungup:=true;
end;
end;
procedure topscr; forward;
procedure skey(c:char); forward;
procedure getkey(var c:char); forward;
procedure pr1(i:str);
var c:integer;
begin
for c:=1 to length(i) do o1(i[c]);
end;
procedure pr(i:str);
begin
pr1(i+#13);
end;
procedure prompt(i:str);
var c:integer; cc:char;
begin
checkhangup;
if not hangup then begin
for c:=1 to length(i) do begin
if (not ((i[c]=chr(7)) and (incom))) and (i[c]<>chr(12)) and (i<>#1) then write(i[c]);
if chatcall then sound(1000);
o(i[c]);
if i[c]>#31 then thisline:=thisline+i[c];
if i[c]=#8 then if length(thisline)>0 then thisline:=copy(thisline,1,length(thisline)-1);
if i[c]=chr(12) then begin lil:=0; clrscr; topscr; end;
if i[c]=chr(13) then begin pap:=0; thisline:=''; end;
nosound;
if i[c]=chr(10) then begin
lil:=lil+1;
if (lil>=thisuser.pagelen-1) then begin
lil:=0;
if pause in thisuser.defaults then begin
prompt('(-*-)');
getkey(cc); skey(cc); prompt(' '+chr(8));
for cc:='A' to 'E' do
prompt(chr(8)+' '+chr(8));
end;
end;
end;
end;
end;
end;
procedure print(i:str);
begin
prompt(i+chr(13)+chr(10))
end;
procedure nl;
begin
prompt(chr(13)+chr(10))
end;
procedure tleft;
var x,y:integer;
begin
if okt then begin
x:=wherex; y:=wherey; window(1,1,80,4);
gotoxy(72,3);if chatcall then begin
write('CHAT ON');
if alert in thisuser.option then begin
gotoxy(72,3);
write('ALERT ');
end;
end else write(' ');
gotoxy(56,3); if sysop1 then write('Sysop Available') else
write('----- ---------');
if useron then begin
gotoxy(35,3); if thisuser.ontoday<>1 then write('ML=',extramsgs+seclev[thisuser.sl].mallowed-mread,' ');
gotoxy(45,3); write('TL=',((seclev[thisuser.sl].ttime*60+extratime+timeon-timer)/60):6:2,' ');
end;
if hangup then begin
gotoxy(72,3);
write('HANG UP');
end;
window(1,5,80,25);gotoxy(x,y);
if timer<timeon then timeon:=timeon-24.0*60*60;
if not ch and ((seclev[thisuser.sl].ttime*60+extratime+timeon-timer)<0) and useron then
begin nl; print('Time expired.'); hangup:=true; end;
checkhangup;
end;
end;
procedure prestrict(u:userrec);
var r:restrictions;
begin
for r:=rlogon to rmsg do
if r in u.ac then write(copy('LCVBA*PEKM',ORD(R)+1,1)) else write(' ');
writeln;
end;
procedure ff(i:integer);
begin
while wherex<i do write(' ');
end;
procedure topscr;
var c:char; x,y,i:integer;
begin
if (usernum<>0) and okt then begin
x:=wherex; y:=wherey;
window(1,1,80,5);
gotoxy(1,1); write(chr(186),' ',nam); ff(35);
with thisuser do begin
write(realname);ff(50);write(ph);ff(65);
if laston<>date then write(laston);
ff(76); if date=laston then write(ontoday); ff(79);
write(' ',chr(186));gotoxy(1,2);
write(chr(186),' SL=',sl);ff(10);write('AR=');
for c:='A' to 'G' do if c in ar then write(c) else write(' ');
write(' LO=',loggedon);
ff(28);write('P=',msgpost);ff(35);write('E=',emailsent);
ff(42);write('F=',feedback);ff(48);
write('W=',waiting);ff(54);
if not useron then write('"',pw,'"') else write('SC=',thisuser.linelen,'X',
thisuser.pagelen,' ');
ff(68);write('FW=',fw); ff(74); write('D=',thisuser.dsl);
gotoxy(80,2);write(#186);
gotoxy(1,3);write(#186,' AC='); prestrict(thisuser);
gotoxy(17,3);write('C=',comptyp[thisuser.comptype]);
gotoxy(80,3);write(chr(186));
gotoxy(1,4);write(chr(200));
for i:=2 to 79 do
write(chr(205));
write(chr(188));
end;
window(1,5,80,25);gotoxy(x,y);
tleft;
end;
end;
function empty:boolean;
begin
if incom then empty:=not commpressed else empty:=true;
if keypressed then empty:=false;
if hangup then begin dump; empty:=true; end;
end;
function inkey:char;
var c:char;
begin
c:=chr(0); inkey:=chr(0);
if keypressed then begin
read(kbd,c); if c=chr(27) then
if keypressed then begin
read(kbd,c);
c:=chr(ord(c) or 128);
end;
inkey:=c;
end else begin
if commpressed and incom then begin
inkey:=cinkey;
end;
end;
end;
procedure oc(c:char);
begin
if c=chr(8) then bs else if c<>chr(0) then write(C);
o(c);
end;
procedure outkey(c:char);
begin
if (c<>chr(12)) and (not ((c=chr(7)) and (incom))) then if c=chr(8) then bs else if c<>#0 then write(c);
if (not echo) and (c>=' ') then c:='X';
o(c);
if c=chr(12) then begin clrscr; topscr; end;
if c=#7 then begin o(#0); o(#0); o(#0); o(#0); end;
end;
procedure phelp; forward;
procedure ptime; forward;
procedure getkey;
var p:integer; t:real; tf,t1:boolean;
begin
if buf<>'' then begin
c:=buf[1]; buf:=copy(buf,2,length(buf)-1);
end else if not empty then c:=inkey else begin
p:=1; t:=timer; t1:=false; tf:=false; lil:=0;
c:=chr(0);
while (c=chr(0)) and not hangup do begin
c:=inkey;
if empty and (c=chr(0)) then begin
if (spcsr in thisuser.defaults) then begin
oc(cursor[p]); t1:=true;
p:=p+1; if p>length(cursor) then p:=1;
end;
end;
if (timer-t)>180 then begin nl;
print('Call back later when you are there.');hangup:=true;
sysoplog('!-!-! TIMEOUT !-!-!');
end;
if ((timer-t)>90) and (not tf) then begin tf:=true; outkey(chr(7)); end;
checkhangup;
end;
if (spcsr in thisuser.defaults) and t1 then begin
if (p mod 2)=0 then
oc(chr(8));
if (c<' ') or (c>=chr(127)) then begin oc(' '); oc(chr(8)); end;
end;
end;
if c=chr(127) then c:=chr(8);
if ((c=#6) or (c=#4)) and macok then begin
if c=#4 then
buf:=thisuser.macro[1]
else
buf:=thisuser.macro[2];
if buf<>'' then begin c:=buf[1]; buf:=copy(buf,2,length(buf)-1); end;
end;
end;
procedure cls;
begin
outkey(chr(12));
end;
procedure chsl;
var ij,i:str; c:integer;
begin
ij:=thisline;
prompt('[WAIT]');
writeln;writeln;write('Enter new SL: ');
readln(i); if i<>'' then thisuser.sl:=value(i); writeln;
if thisuser.sl=99 then begin
write('Board #? '); thisuser.sbn:=0;
readln(i); thisuser.sbn:=value(i);
writeln;
end;
topscr; realsl:=thisuser.sl;
i:=''; for c:=1 to 6 do i:=i+chr(8)+' '+chr(8);
prompt(i);
writeln; thisline:=ij; write(ij);
end;
procedure swac(var u:userrec;r:restrictions);
begin
if r in u.ac then u.ac:=u.ac-[r] else u.ac:=u.ac+[r];
end;
procedure acch(c:char; var u:userrec);
begin
case c of
'L':swac(u,rlogon);
'C':SWAC(u,RCHAT);
'V':SWAC(u,RVALIDATE);
'B':SWAC(u,RBACKSPACE);
'A':SWAC(u,RAMSG);
'*':SWAC(u,RPOSTAN);
'P':SWAC(u,RPOST);
'E':SWAC(u,REMAIL);
'K':SWAC(u,RVOTING);
'M':swac(u,rmsg);
END;
end;
procedure chac(var thisuser:userrec);
var c:char; ij,i:str; cc:integer;
begin
ij:=thisline;
prompt('[WAIT]');
writeln;writeln('LCVBA*PEKM');writeln;write('Which? '); read(kbd,c); c:=upcase(c); writeln(c); writeln;
acch(c,thisuser);
topscr;
i:=''; for cc:=1 to 6 do i:=i+chr(8)+' '+chr(8);
prompt(i);
writeln;
thisline:=ij; write(ij);
END;
procedure chat; forward;
procedure chdsl;
var ij,i:str; c:integer;
begin
ij:=thisline;
prompt('[WAIT]');
writeln;writeln;
writeln('UL=',thisuser.uploads,'-',thisuser.uk,'K DL=',thisuser.downloads,'-',thisuser.dk,'K');
write('Enter new DSL: ');
readln(i); if i<>'' then thisuser.dsl:=value(i); writeln;
i:=''; for c:=1 to 6 do i:=i+chr(8)+' '+chr(8);
topscr;
prompt(i);
writeln; thisline:=ij; write(ij);
end;
procedure tfile;
var i:str; ii:integer;
bf:file of byte; cr:boolean;
begin
if cfo then begin
cfo:=false;
close(cf);
write('<CLOSED>');
end else begin
assign(cf,'gfiles\chat.msg');
assign(bf,'gfiles\chat.msg'); cr:=false;
{$I-} reset(bf); {$I+}
if ioresult<>0 then cr:=true
else begin
if filesize(bf)=0 then cr:=true;
close(bf);
end;
if cr then rewrite(cf) else append(cf);
cfo:=true;
i:=#13+#10+#13+#10+dat+#13+#10+'==============='+#13+#10;
writeln(cf,i);
write('<OPEN>');
end;
end;
procedure skey;
var b:boolean;
begin
case ord(c) of
3:if spcsr in thisuser.defaults then
thisuser.defaults:=thisuser.defaults-[spcsr] else
thisuser.defaults:=thisuser.defaults+[spcsr];
26:phelp;
20:ptime;
187:chsl;
212:chdsl;
188:chac(thisuser);
189:begin
if outcom then incom:=not incom;
writeln; if incom then writeln('<INPUT ENABLED>')
else writeln('<COM DISABLED>');
writeln;dump;
write(thisline);
end;
190:chatcall:=false;
195:begin
if thisuser.sl=255 then if realsl<>255 then begin
thisuser.sl:=realsl; writeln;writeln;writeln('<SECLEV RESTORED>');
writeln; write(thisline); end
else else begin
thisuser.sl:=255; writeln;writeln;writeln('<TEMP SYSOP GRANTED>');
writeln; write(thisline);
end; topscr;
end;
196:if not ch then chat;
199:if ch then tfile;
191:hangup:=true;
192:tleft;
193:begin b:=ch; ch:=true; extratime:=extratime-5*60; tleft; ch:=b;end;
194:begin b:=ch; ch:=true; extratime:=extratime+5*60; tleft; ch:=b;end;
218:begin b:=ch; ch:=true; extramsgs:=extramsgs-10; tleft; ch:=b; end;
219:begin b:=ch; ch:=true; extramsgs:=extramsgs+10; tleft; ch:=b; end;
end;
if (c>chr(127)) and (c<>chr(196)) then c:=chr(0);
end;
procedure inli1(var i:str);
var cp:integer; c:char; cv,cc:integer;
begin
cp:=1;
i:='';
if ll<>'' then begin prompt(ll); i:=ll; ll:=''; cp:=length(i)+1;end;
repeat
getkey(c); skey(c); checkhangup;
case ord(c) of
32..126:if (cp<79) then begin
i[cp]:=c; cp:=cp+1; outkey(c);
end;
127,8:if cp>1 then begin c:=chr(8);
prompt(c+' '+c); cp:=cp-1;
end;
24:begin
for cv:=1 to cp-1 do prompt(chr(8)+' '+chr(8)); cp:=1;
end;
7:o(#7);
23:if cp>1 then repeat
prompt(chr(8)+' '+chr(8)); cp:=cp-1;
until (cp=1) or (i[cp]=' ');
9:begin
cv:=5-(cp mod 5); if (cp+cv<79) then
for cc:=1 to cv do begin
prompt(' ');
i[cp]:=' '; cp:=cp+1;
end;
end;
end;
until (c=#13) or (cp=79) or hangup or (c=#196);
if c=#196 then begin c:=#13; ch:=false; end;
i[0]:=chr(cp-1);
if c<>chr(13) then begin
cv:=cp-1;
while (cv>0) and (i[cv]<>' ') and (i[cv]<>chr(8))do cv:=cv-1;
if (cv>(cp div 2)) and (cv<>cp-1) then begin
ll:=copy(i,cv+1,cp-cv); for cc:=cp-2 downto cv do prompt(chr(8));
for cc:=cp-2 downto cv do prompt(' ');
i[0]:=chr(cv-1);
end;
end;
nl;
end;
procedure chat;
var c,ohl:char; tf:boolean; sp,xx:str; x:integer; t,t1:real;
begin
sp:=thisline; ch:=true; chatcall:=false; tf:=echo; echo:=true;nl;nl; t:=timer;
thisuser.option:=thisuser.option-[alert]; ohl:=helpl; helpl:=#0;
print('Sysop''s here...'); nl;
if chatr<>'' then begin
writeln; writeln; writeln('Reason: ',chatr); writeln; writeln; chatr:='';
end;
repeat
inli1(xx);
if (xx='/quitchat') or (xx='/QUITCHAT') then begin
t1:=timer; while (abs(t1-timer)<4.0) and (not keypressed) do;
if not keypressed then ch:=false;
end else if cfo then writeln(cf,xx);
until (not ch) or hangup;
nl;print('Chat mode over...'); nl;
extratime:=extratime+timer-t; ch:=false; echo:=tf;
if hangup and cfo then begin
writeln(cf); writeln(cf,'<HANGUP>');
end;
prompt(sp); thisline:=sp;
if cfo then begin cfo:=false; close(cf); end;
helpl:=ohl;
end;
function yn:boolean;
var c:char;
begin
if not hangup then begin
repeat
getkey(c);
skey(c);
c:=upcase(c);
until (c='Y') or (c='N') or (c=chr(13)) or hangup;
if c='Y' then begin print('Yes'); yn:=true; end else begin print('No'); yn:=false; end;
if hangup then yn:=false;
end;
end;
procedure input1(var i:str; ml:integer; tf:boolean);
var cp:integer;
c:char;
r:real;
begin
checkhangup;
if not hangup then begin
r:=timer;
cp:=1;
repeat
getkey(c);
skey(c);
if c=#196 then r:=timer;
if not tf then c:=upcase(c);
if (c>=' ') and (c<chr(127)) then
if cp<=ml then begin
i[cp]:=c;
cp:=cp+1;
outkey(c);
thisline:=thisline+c;
end else else case ord(c) of
127,8:if cp>1 then begin
c:=chr(8);
outkey(c);outkey(' '); outkey(c);
cp:=cp-1;
if length(thisline)>0 then thisline:=copy(thisline,1,length(thisline)-1);
end;
21,24:while cp<>1 do begin
cp:=cp-1;
outkey(#8);outkey(' '); outkey(#8);
if length(thisline)>0 then thisline:=copy(thisline,1,length(thisline)-1);
end;
end;
if (timer-r)>300.0 then hangup:=true;
until (c=#13) or (c=#14) or hangup;
i[0]:=chr(cp-1);
nl;
end;
end;
procedure input(var i:str; ml:integer);
begin
input1(i,ml,false);
end;
procedure inputl(var i:str; ml:integer);
begin
input1(i,ml,true);
end;
function find(c:char; s:str):boolean;
var i:integer; tf:boolean;
begin
c:=upcase(c);
tf:=false;
for i:=1 to length(s) do
if c=upcase(s[i]) then tf:=true;
find:=tf;
end;
procedure onek(var c:char; ch:str);
var i1,i:str; tf:boolean;
begin
i1:=thisline; tf:=false;
repeat
if not(onekey in thisuser.defaults) then begin
if tf then prompt(i1);
input(i,3);
if length(i)=1 then c:=i[1] else c:=' ';
end else begin
getkey(c);
skey(c);
c:=upcase(c);
end;
tf:=true;
until find(c,ch) or hangup;
if not find(c,ch) then c:=ch[1];
if onekey in thisuser.defaults then print(''+c);
end;
procedure centre(var i:str);
begin
if pap<>0 then nl;
if i[1]=#2 then i:=copy(i,2,length(i)-1);
if length(i)<thisuser.linelen then
i:=copy(' ',1,
(thisuser.linelen-length(i)) div 2)+i;
end;
procedure printa1(i:str; var abort,next:boolean);
var c:integer; cc:char;
procedure wkey;
begin
while (not empty) and (not hangup) do begin
cc:=inkey; skey(cc);
if (cc=' ') or (cc=chr(3)) or (cc=chr(24)) or (cc=chr(11)) then
abort:=true;
if (cc=chr(14)) then begin abort:=true; next:=true; end;
if (cc=chr(19)) or (cc='P') or (cc='p') then begin
getkey(cc); skey(cc);
end;
end;
end;
begin
checkhangup;
if not hangup then begin
abort:=false; next:=false; c:=1;
wkey;
while (not abort) and (c-1<>length(i)) and (not hangup) do begin
checkhangup;
if i[c]=chr(8) then pap:=pap-1 else if i[c]<>chr(10) then pap:=pap+1;
wkey;
outkey(i[c]);
c:=c+1;
end;
end else abort:=true;
end;
procedure printa(i:str; var abort,next:boolean);
var s:str; p,lp,rp:integer;
begin
abort:=false;
p:=1; rp:=0; lp:=1;
if i[1]=#2 then begin
if i[length(i)]=#1 then i:=copy(i,1,length(i)-1);
centre(i);
printa1(i,abort,next);
nl;
end else begin
while (p<=length(i)) and (not abort) and (not hangup) do begin
rp:=0;
while (i[p]<>' ') and (p<=length(i)) and (not hangup) do begin
if i[p]=chr(8) then rp:=rp-1 else
if (i[p]<>#10) and (i[p]<>#1) then rp:=rp+1;
p:=p+1;
end;
if i[p]=' ' then rp:=rp+1;
s:=copy(i,lp,(p-lp+1)); p:=p+1; lp:=p;
if s[length(s)]=#1 then s:=copy(s,1,length(s)-1);
if s<>'' then if (copy(s,length(s),1)<>' ') and (i[length(i)]<>#1) then s:=s+' ';
if (pap+rp>=thisuser.linelen) then nl;
printa1(s,abort,next);
end;
if not abort then printa1('',abort,next);
if abort or (i[length(i)]=#1) or (length(i)=0) then nl;
end;
end;
procedure printacr(i:str; var abort,next:boolean);
begin
if not abort then
if i[length(i)]=#1 then
printa(i,abort,next)
else
printa(i+#1,abort,next);
end;
function tlef:str;
var rl:real; inte:integer; i,ii:str;
begin
rl:=(seclev[thisuser.sl].ttime*60.0+extratime+timeon-timer);
if rl>32767.0 then rl:=32000; if rl<0.0 then rl:=0;
inte:=trunc(rl);
i:=cstr(inte div 3600)+':'; ii:=cstr((inte mod 3600) div 60);
if length(ii)=1 then ii:='0'+ii; i:=i+ii+':';
ii:=cstr(inte mod 60); if length(ii)=1 then ii:='0'+ii;
tlef:=i+ii;
end;
procedure phelp;
var i,lli:str; c:integer; abort,next:boolean;
begin
ihelp:=true;
lli:=thisline;
if helpl in ['0'..'^'] then
if helpi[helpl]>0 then begin
cls;
c:=helpi[helpl];
i:=''; abort:=false;
while (help[c]<>'|') and (not abort) do begin
if help[c]=#10 then begin
printacr(i,abort,next);
i:='';
end else
if help[c]<>#13 then
i:=i+help[c];
c:=c+1;
end;
nl; nl; nl;
prompt(lli);
end;
ihelp:=false;
end;
procedure ptime;
var i:str;
begin
if useron then begin
i:=thisline;
nl; nl; print(dat);
print('Time left: '+tlef);
nl; prompt(i);
end;
end;